home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / ai / fuzzy / io.b < prev    next >
Text File  |  1986-11-29  |  10KB  |  267 lines
  1. -------------------------------------------------------------------------------
  2. --                                                                           --
  3. --  Library Unit:  io  --  Source and Listing I/O                            --
  4. --                                                                           --
  5. --  Author:  Bradley L. Richards                                             --
  6. --                                                                           --
  7. --     Version     Date     Notes . . .                                      --
  8. --    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -    --
  9. --       1.0     6 Feb 86   Initial Version                                  --
  10. --       1.1    25 Feb 86   Minor revisions to error messages                --
  11. --       1.2     4 Mar 86   Added 2 character lookahead (required to         --
  12. --                            differentiate between the Ada ellipse and      --
  13. --                            a floating point number).                      --
  14. --       1.3    22 May 86   Split error handlers into separate package       --
  15. --                            to limit higher level visibility               --
  16. --       1.4    18 Jun 86   Allow variable lookahead (1 or 2 characters)     --
  17. --       2.0    20 Jun 86   Version number change only (for consistancy)     --
  18. --       2.1    13 Jul 86   Fixed bugs pertaining to interactive i/o         --
  19. --                          Split into separate spec and body files          --
  20. --       2.2    28 Jul 86   Reset line number, et al in Start_IO.  Altered   --
  21. --                          end-of=line logic to eliminate the need for the  --
  22. --                          user to type an extra character on interactive   --
  23. --                          input.  Initial operational version.             --
  24. --       3.0    10 Oct 86   Final thesis product                             --
  25. --    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -    --
  26. --                                                                           --
  27. --  Library units used:  text_io                                             --
  28. --                                                                           --
  29. --  Description:  This package handles all source file access and listing    --
  30. --     output for an interpreter or compiler.  It assumes a maximum output   --
  31. --     file width of 132 characters; since it reserves the first seven       --
  32. --     character positions for line numbering, it accepts a maximum of       --
  33. --     125 characters on an input line (defined as a constant in the         --
  34. --     package specification).                                               --
  35. --          The package suppresses empty lines entirely.  When it reaches    --
  36. --     the end of a line which did contain data, it returns an ascii.cr as   --
  37. --     the end-of-line delimiter.                                            --
  38. --          To initialize the package, call start_io with the names of the   --
  39. --     source and listing files.  Characters are retrieved by get_char,      --
  40. --     which returns the current character and two lookahead characters.     --
  41. --     The first character retrieved from any file is an ascii.nul (in       --
  42. --     other words, the true first character appears initially as the        --
  43. --     first lookahead character.  When the end of the source file is        --
  44. --     reached get_char returns an ascii.eot.  further read requests         --
  45. --     produce more ascii.eot characters.                                    --
  46. --          Comments may be inserted with the routines "lput," "lput_line,"  --
  47. --     and "lnew_line."  These are equivalent to the normal text_io          --
  48. --     routines, but take the listing format into account.  If desired, a    --
  49. --     pointer to the current character can be printed by "pointer."         --
  50. --          If the listing file name is empty then listing output and        --
  51. --     pointers are suppressed and comments are written to the standard      --
  52. --     output with line and character number references.                     --
  53. --          After everything is finished, stop_io will tidy up the           --
  54. --     files, and handle any post_processing required by the package.        --
  55. --                                                                           --
  56. -------------------------------------------------------------------------------
  57. --                                                                           --
  58. --                              Package Body                                 --
  59. --                                                                           --
  60. -------------------------------------------------------------------------------
  61.  
  62. package body io is
  63.  
  64.   package int_io is new integer_io(integer); use int_io;
  65.  
  66.   line_counter, line_length, prev_line_length, char_ptr : integer;
  67.   read_current, write_current : boolean;
  68.   source_file, listing_file : file_type;
  69.   line_buffer : string(1..max_line_length);
  70.   previous_comment : boolean := false;
  71.   look_ahead : integer;
  72.  
  73.  
  74.   procedure get_char is
  75.     begin
  76.       current_char := look_ahead_char;
  77.       if look_ahead = 1 then
  78.     look_ahead_char := internal_get_char;
  79.       else -- look_ahead = 2
  80.         look_ahead_char := look_ahead_2_char;
  81.         look_ahead_2_char := internal_get_char;
  82.       end if;
  83.     end get_char;
  84.  
  85.  
  86.   function internal_get_char return character is
  87.       eof_marker : constant character := ascii.eot;
  88.       eof : boolean;
  89.     begin
  90.       if char_ptr = line_length then
  91.     char_ptr := char_ptr + 1;
  92.     return ascii.cr;
  93.       elsif char_ptr >= line_length then       -- past the end of line?
  94.         loop -- until we get a nonempty line
  95.       if read_current then
  96.             eof := end_of_file;                -- check before read
  97.       else
  98.             eof := end_of_file(source_file);
  99.       end if;
  100.       if not eof then
  101.         prev_line_length := line_length;
  102.         if read_current then
  103.               get_line(line_buffer,line_length);
  104.         else
  105.               get_line(source_file,line_buffer,line_length);
  106.         end if;
  107.         line_counter := line_counter + 1;
  108.         if previous_comment then
  109.           if write_current then
  110.         new_line;
  111.           else
  112.             new_line(listing_file);
  113.           end if;
  114.           previous_comment := false;
  115.         end if;
  116.         if not write_current then -- we are creating a listing file
  117.           put(listing_file, line_counter,5); put(listing_file,":  ");
  118.               put_line(listing_file, line_buffer(1..line_length));
  119.         end if;
  120.       end if;
  121.       exit when (line_length > 0) or eof;
  122.     end loop;
  123.     if eof then
  124.       return eof_marker;                   -- return EOT
  125.         else
  126.       char_ptr := 1;
  127.       return line_buffer(char_ptr);        -- return first char of the line
  128.     end if;
  129.       else
  130.         char_ptr := char_ptr + 1;
  131.     return line_buffer(char_ptr);
  132.       end if;
  133.     end internal_get_char;
  134.  
  135.  
  136.   procedure lnew_line is
  137.     begin
  138.       if write_current then
  139.         new_line;
  140.       else
  141.         new_line(listing_file);
  142.       end if;
  143.       previous_comment := false;
  144.     end lnew_line;
  145.  
  146.  
  147.   procedure lput(comment : in string) is
  148.     begin
  149.       if not previous_comment then
  150.       if not write_current then
  151.             put(listing_file, "      ");    -- space out past line numbers
  152.       end if;
  153.       previous_comment := true;
  154.         end if;
  155.       if write_current then
  156.     put(comment);
  157.       else
  158.         put(listing_file, comment);
  159.       end if;
  160.     end lput;
  161.  
  162.  
  163.   procedure lput_line(comment : in string) is
  164.     begin
  165.       if not previous_comment then
  166.       if not write_current then
  167.         put(listing_file, "      ");    -- space out past line numbers
  168.       end if;
  169.     end if;
  170.       if write_current then
  171.     put_line(comment);
  172.       else
  173.         put_line(listing_file, comment);
  174.       end if;
  175.       previous_comment := false;
  176.     end lput_line;
  177.  
  178.  
  179.   procedure print_pointer is
  180.       ptr_line : string(1..max_line_length) := (others => ' ');
  181.     begin
  182.       if previous_comment then
  183.         new_line(listing_file);
  184.         previous_comment := false;
  185.       end if;
  186.       if write_current then -- print line and character number
  187.     if char_ptr < look_ahead then
  188.       put("line ");
  189.       put(line_counter - 1, 3);
  190.       put(", character ");
  191.       put(prev_line_length - look_ahead + char_ptr + 1, 4);
  192.       put(" -- ");
  193.     elsif char_ptr = look_ahead then
  194.       put("end of line ");
  195.       put(line_counter - 1, 4);
  196.       put(" -- ");
  197.     else
  198.       put("line ");
  199.       put(line_counter, 4);
  200.       put(", character ");
  201.       put(char_ptr - look_ahead, 3);
  202.       put(" -- ");
  203.     end if;
  204.     previous_comment := true;
  205.       else -- print a pointer
  206.         if char_ptr = (look_ahead - 1) then
  207.       lput_line("Error on last character of previous line");
  208.         elsif char_ptr = look_ahead then
  209.       lput_line("Error on previous end-of-line character");
  210.         else
  211.           if char_ptr > look_ahead then
  212.             for ctr in 1..(char_ptr - look_ahead - 1) loop
  213.               ptr_line(ctr) := '.';
  214.             end loop;
  215.       end if;
  216.           ptr_line(char_ptr - look_ahead) := '^';
  217.           lput_line(ptr_line(1..char_ptr - look_ahead));
  218.         end if;
  219.       end if;
  220.     end print_pointer;
  221.  
  222.  
  223.   procedure start_io(source_name, listing_name : string; look_ahead : vision) is
  224.     begin
  225.  
  226.       line_counter := 0;
  227.       line_length := 0;
  228.       prev_line_length := 0;
  229.       char_ptr :=0;
  230.  
  231.       io.look_ahead := look_ahead;                     -- set package lookahead
  232.  
  233.       if listing_name = "" then                        -- use current output
  234.     write_current := true;
  235.       else
  236.     write_current := false;
  237.         create(listing_file, out_file, listing_name);  -- create listing file
  238.       end if;
  239.  
  240.       if source_name = "" then                         -- use current input
  241.     read_current := true;
  242.       else
  243.     read_current := false;
  244.         open(source_file, in_file, source_name);       -- open source file
  245.       end if;
  246.       for count in 1..look_ahead loop
  247.     get_char;                                      -- get first char ready
  248.       end loop;
  249.  
  250.     end start_io;
  251.  
  252.  
  253.   procedure stop_io is
  254.     begin
  255.  
  256.       if not read_current then
  257.         close(source_file);
  258.       end if;
  259.  
  260.       if not write_current then
  261.         close(listing_file);
  262.       end if;
  263.  
  264.     end stop_io;
  265.  
  266. end io;
  267.